-----------------------------------------------------------------------------
-- |
-- Module      : LLVM.Parser.Record.Record
-- Copyright   : Mikhail Belyaev
-- License     : GPLv3 (see LICENSE)
--
-- RawRecords, RawBlocks and ways to use them
-- RecordType class for records
-----------------------------------------------------------------------------
module LLVM.Parser.Record.Record where

import LLVM.Parser.Bits.Struct
import LLVM.Util

import Data.Char
import Control.Monad
import Data.Maybe (isJust, catMaybes)

-- Special record ids
cEND_BLOCK = 0
cENTER_SUBBLOCK = 1
cDEFINE_ABBREV = 2
cUNABBREV_RECORD = 3

-- Raw record type, built on id and fields of data
data RawRecord = RawRecord { recId :: Integer, recData :: [FieldVal] } deriving Show

-- test if record @r@ has an id of @id@
isIdOf :: Integer -> RawRecord -> Bool
isIdOf id r = recId r == id

-- test if the record is a block entry
isBlockEntry :: RawRecord -> Bool
isBlockEntry = isIdOf cENTER_SUBBLOCK

-- test if the record is a block closing rec
isBlockClosing :: RawRecord -> Bool
isBlockClosing = isIdOf cEND_BLOCK

-- test if the record is an abbr def
isAbbrDefinition :: RawRecord -> Bool
isAbbrDefinition = isIdOf cDEFINE_ABBREV

-- test if the record is unabbreviated
isUnAbbr :: RawRecord -> Bool
isUnAbbr = isIdOf cUNABBREV_RECORD

-- raw block, an info header and a list of elems
data RawBlock = RawBlock { header :: BlockHeader, contents :: [RawBlockElem] } deriving Show
-- block elem, a sub elem or a record
data RawBlockElem = Data RawRecord | Sub RawBlock deriving Show

fromData :: RawBlockElem -> Maybe RawRecord
fromData (Data x) = Just x
fromData _ = Nothing

fromSub :: RawBlockElem -> Maybe RawBlock
fromSub (Sub x) = Just x
fromSub _ = Nothing

extrudeData :: (RecordType a) => RawBlockElem -> Maybe a
extrudeData rbe = flop (liftM fromRawRecord $ fromData rbe)

extrudeCustomRecords :: (RecordType a) => RawBlock -> [a]
extrudeCustomRecords rb = maybeFilter extrudeData $ contents rb

extrudeSub :: (BlockType a) => RawBlockElem -> Maybe a
extrudeSub rbe = flop (liftM fromRawBlock $ fromSub rbe)

extrudeCustomSubblocks :: (BlockType a) => RawBlock -> [a]
extrudeCustomSubblocks rb = maybeFilter extrudeSub $ contents rb

-- add record to block
addRecord :: RawBlock -> RawRecord -> RawBlock
addRecord block record = let newcont = (Data record):(contents block) in
                         block{contents = newcont};

-- add subblock to block
addBlock :: RawBlock -> RawBlock -> RawBlock
addBlock block subblock = let newcont = (Sub subblock):(contents block) in
                          block{contents = newcont};

-- class of types that can be cast from raw records
class RecordType r where
        fromRawRecord :: RawRecord -> Maybe r

-- class of types that can be cast from raw blocks
class BlockType b where
        fromRawBlock :: RawBlock -> Maybe b

-- block header is a record that starts the block
-- it contains block id, block size and abbreviation length
data BlockHeader = BlockHeader { blockId :: Integer, blockSize :: Integer, abbrLen :: Integer } deriving (Show,Eq)

-- block header is a rather simple kind of record
instance RecordType BlockHeader where
        -- 1 is the cENTER_SUBBLOCK constant
        fromRawRecord (RawRecord 1 [IntVal id, IntVal alen, Void, IntVal bsize]) =
                                                   Just $ BlockHeader id bsize alen
        fromRawRecord _ = Nothing

-- unAbbrevs can be tricky
-- contains generic code and a number of integral parameters
data UnAbbreviated = UnAbbreviated{ code :: Integer, parameters :: [Integer] } deriving Show

-- reading an unnabbrev from a raw record is tricky as the parameters number is not known
instance RecordType UnAbbreviated where
        -- 3 is the cUNABBREV_RECORD constant
        fromRawRecord (RawRecord 3 [IntVal code, Many others]) =
                               let maybes = map integerValueOf others
                                   decodeL = if (isJust `all` maybes)
                                                then Just $ catMaybes maybes
                                                else Nothing
--                                   decodeL flist = case flist of
--                                                        [] -> Just []
--                                                        (IntVal value):rest -> case (decodeL rest) of
--                                                                                    Just list -> Just (value:list)
--                                                                                    Nothing -> Nothing
--                                                        _ -> Nothing

                               in
                                   case (decodeL) of
                                        Nothing -> Nothing
                                        Just lst -> Just $ UnAbbreviated code lst
        fromRawRecord _ = Nothing

-- no id 'cos there's no way to find it out without parser context
data AbbreviationDef = AbbreviationDef{ structure :: [StructElem] } deriving Show

-- parse a definition record to a record structure
-- definitelly awful function it's gonna be
parseDefStructure :: [FieldVal] -> (Maybe StructElem,[FieldVal])
-- literal value is just a constant, not even read from anywhere
parseDefStructure ((Many [IntVal 1, IntVal operand]):tail) =
        (Just $ Const (IntVal operand), tail)
-- FBR, simple
parseDefStructure ((Many [IntVal 0, Many [IntVal 1, IntVal operand]]):tail) =
        (Just $ Prim $ Integral $ FBR $ fromInteger operand, tail)
-- VBR, simple
parseDefStructure ((Many [IntVal 0, Many [IntVal 2, IntVal operand]]):tail) =
        (Just $ Prim $ Integral $ VBR $ fromInteger operand, tail)
-- array, rather comlicated thingie
parseDefStructure ((Many [IntVal 0, Many [IntVal 3, Void]]):tail) = -- lets pick next element
                let (elem,rest) = parseDefStructure(tail) in
                case elem of
                     Nothing -> (Nothing, tail)
                     Just elem'' -> (Just $ Arr (VBR 6) elem'', rest)
parseDefStructure ((Many [IntVal 0, Many [IntVal 4, Void]]):tail) = (Just $ Prim Char6, tail)
-- blob, even moar compicated
parseDefStructure ((Many [IntVal 0, Many [IntVal 5, Void]]):tail) =
                let
                        align32 = Prim Align32
                        byte = Prim $ Integral $ FBR 8

                        blob (IntVal sz) = meSucceed $ Comp $ [align32] ++ replicate (fromInteger sz) byte ++ [align32]
                        blob _ = meFail "Implementation defined structure couldn't load: trying to load blob with non-integral size value"
                in
                        (Just $ Variable (Prim $ Integral $ VBR 6) blob, tail)
-- could actually consume the first elem, doesn't really matter
parseDefStructure lst = (Nothing, lst)

iterlist :: [FieldVal] -> Maybe [StructElem]
iterlist fvs =  let rec [] o = o
                    rec i  o =
                        let (el,i'') = parseDefStructure i in
                        case (el,o) of
                             (Nothing,_) -> Nothing
                             (_,Nothing) -> Nothing
                             (Just elem, Just o'') -> rec i'' $ Just $ o'' ++ [elem]

                in rec fvs $ Just []

instance RecordType AbbreviationDef where
        -- 2 is the cDEFINE_ABBREV constant
       fromRawRecord (RawRecord 2 [Many others]) =
           liftM AbbreviationDef $ iterlist others
       fromRawRecord _ = Nothing

getCode :: RawRecord -> Maybe Integer
getCode rr = case (flattenRecord rr) of
                  (RawRecord 0 _) -> Nothing -- blockstart
                  (RawRecord 1 _) -> Nothing -- blockend
                  (RawRecord 2 _) -> Nothing -- abbrdef
                  (RawRecord _ (s:_)) -> integerValueOf s
                  _ -> Nothing

flattenRecord :: RawRecord -> RawRecord
flattenRecord (RawRecord id dat) = RawRecord id $ flattenData dat
                                   where
                                   flattenData [] = []
                                   flattenData (l:ls) = flattenPiece l ++ flattenData ls
                                   flattenPiece (IntVal val) = [IntVal val]
                                   flattenPiece (CharVal val) = [IntVal $ toInteger $ ord val]
                                   flattenPiece (Void) = []
                                   flattenPiece (Many vals) = flattenData vals

recordAsList :: RawRecord -> [Integer]
recordAsList rec = let RawRecord id els = flattenRecord rec in
                   id:(maybeFilter integerValueOf els)

recordAsHeadlessList :: RawRecord -> [Integer]
recordAsHeadlessList = tail . recordAsList

-- if @rec@ has code @cd@, returns @True@
-- if @rec@ has no code or it's not @cd@, returns @False@
hasCode :: Integer -> RawRecord -> Bool
hasCode cd rec = rec.$getCode.?(== cd) ?? False

getBlockId :: RawBlock -> Integer
getBlockId = blockId.header

isBlockIdOf :: Integer -> RawBlock -> Bool
isBlockIdOf id rb = id == getBlockId rb

getSubsById :: RawBlock -> Integer -> [RawBlock]
getSubsById rb id = filter (id `isBlockIdOf`) (maybeFilter fromSub $ rb.$contents)

getRecordsByCode :: RawBlock -> Integer -> [RawRecord]
getRecordsByCode rb id = filter (hasCode id) (maybeFilter fromData $ rb.$contents)

extrudeCustomRecordsByCode :: (RecordType a)=> RawBlock -> Integer -> [a]
extrudeCustomRecordsByCode rb id = maybeFilter fromRawRecord $ getRecordsByCode rb id

extrudeCustomSubblocksById :: (BlockType a)=> RawBlock -> Integer -> [a]
extrudeCustomSubblocksById rb id = maybeFilter fromRawBlock $ getSubsById rb id
